﻿<%
'生成组件
'read utf8/gb2312 file
Private Function NewRead(FileUrl, Charset)
	If "gb2312" <> Charset Then Charset = "utf-8"
	Dim stm
	Set stm = Server.CreateObject("ADODB.Stream")
	With stm
		.Type = 2
		.Mode = 3
		.Open
		.LoadFromFile FileUrl
		.Charset = Charset
		.Position = 2
		NewRead = .ReadText
		.Close
	End With
	Set stm = Nothing
End Function
'write utf-8/gb2312 file
Private Function Write2File(FileUrl, tmpStr, Charset)
	'新增功能，替换空格、TAB、回车、注释！
	tmpStr = Replace(Replace(Replace(tmpStr,"	",""),chr(10),""),chr(13),"")
	set regEx = new regExp
	regEx.Pattern = "<!--[^>]*-->"
	regEx.Global=True
	tmpStr = regEx.replace(tmpStr,"")
	
	If "gb2312" <> Charset Then Charset = "utf-8"
	Dim stm, errStr
	errStr = "OK"
	Set stm = Server.CreateObject("ADODB.Stream")
	With stm
		.Type = 2
		.Mode = 3
		.Charset = Charset
		.Open
		.WriteText tmpStr
		.SaveToFile FileUrl, 2
		.Flush
		.Close
	End With
	Set stm = Nothing
End Function
Function HTMLDecode(reString)
	Dim Str:Str=reString
	If Not IsNull(Str) Then
		Str = Replace(Str, "&amp;", "&")
		Str = Replace(Str, "&gt;", ">")
		Str = Replace(Str, "&lt;", "<")
		Str = Replace(Str, "&nbsp;", CHR(32))
	    Str = Replace(Str, "&nbsp;", CHR(9))
		Str = Replace(Str, "&#160;&#160;&#160;&#160;", CHR(9))
		Str = Replace(Str, "&quot;", CHR(34))
		Str = Replace(Str, "&#39;", CHR(39))
		Str = Replace(Str, "", CHR(13))
		Str = Replace(Str, "<br />", CHR(10))
		HTMLDecode = Str
	End If
End Function

Function ClearHTML(strHTML) 
	Dim tStr
	Dim objRegExp, Match, Matches 
	Set objRegExp = New Regexp
	tStr = strHTML
	objRegExp.IgnoreCase = True 
	objRegExp.Global = True 
	objRegExp.Pattern = "<.+?>" 
	Set Matches = objRegExp.Execute(tStr) 
	For Each Match in Matches 
		tStr=Replace(tStr,Match.Value,"")
	Next 
	ClearHTML=tStr 
	Set objRegExp = Nothing 
End Function

Function CheckStr(str) 
	CheckStr=replace(replace(replace(replace(str,"<","&lt;"),">","&gt;"),chr(13),"<br />"),chr(34),"&quot;")
	'CheckStr=replace(replace(replace(replace(replace(CheckStr,"'",""),"and",""),"insert",""),"set",""),"or","") 
	'CheckStr=replace(replace(replace(replace(CheckStr,"select",""),"update",""),"delete%20from",""),chr(34),"&quot;") 
End Function

Function LeftStr(byVal Str,byVal StrLen)
    Dim l,t,c,i
    l=Len(str)
    t=0
    For i=1 To l
        c=AscW(Mid(str,i,1))
        If c<0 Or c>255 Then t=t+2 Else t=t+1
        IF t>=StrLen Then
            LeftStr=left(Str,i)&".."
            Exit For
        Else
            LeftStr=Str
        End If
    Next
End Function

Function IsK(str)
	If Len(str)=0 Or str="" Or IsNull(str) Then
		isK = True
	Else
		isK = False
	End if
End Function

Function IsValidEmail(email)
    Dim names, name, i, c
    IsValidEmail = True
    names = Split(email, "@")
    If UBound(names) <> 1 Then
       IsValidEmail = False
       Exit Function
    End If
    For Each name In names
        If Len(name) <= 0 Then
        IsValidEmail = False
        Exit Function
        End If
        For i = 1 To Len(name)
        c = LCase(Mid(name, i, 1))
        If InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 And Not IsNumeric(c) Then
           IsValidEmail = False
           Exit Function
         End If
       Next
       If Left(name, 1) = "." Or Right(name, 1) = "." Then
          IsValidEmail = False
          Exit Function
       End If
    Next
    If InStr(names(1), ".") <= 0 Then
        IsValidEmail = False
       Exit Function
    End If
    i = Len(names(1)) - InStrRev(names(1), ".")
    If i <> 2 And i <> 3 And i <> 4 Then
       IsValidEmail = False
       Exit Function
    End If
    If InStr(email, "..") > 0 Then
       IsValidEmail = False
    End If
End Function

Sub ShowMsg(str,action)
	Response.Write "<script type='text/javascript'>alert('"&str&"');</script>"
	If action="back" Then
		Response.Write "<script type='text/javascript'>history.back();</script>"
	Else
		Response.Write "<script type='text/javascript'>location.href='"&action&"';</script>"
	End If
	Response.End
End Sub
'date format
Function EnNumDate(ByNumDate)
	dim timeArr1,timeArr2,timeArr3,num_days,num_months,num_years
	timeArr1 = split(ByNumDate," ")
	timeArr2 = split(timeArr1(0),"-")
	timeArr3 = Split(timeArr1(1),":")
	num_hour = timeArr3(0)
	num_minute = timeArr3(1)
	If num_hour >= 0 And num_hour < 12 Then
		dayMode = "am"
	Else 
		dayMode = "pm"
	End if
	num_years = timeArr2(0)
	num_months = timeArr2(1)
	num_days = timeArr2(2)
	select case num_months
		case "1"
			num_months="January"
		case "2"
			num_months="February"
		case "3"
			num_months="March"
		case "4"
			num_months="April"
		case "5"
			num_months="May"
		case "6"
			num_months="June"
		case "7"
			num_months="July"
		case "8"
			num_months="August"
		case "9"
			num_months="September"
		case "10"
			num_months="October"
		case "11"
			num_months="November"
		case else
			num_months="December"
	end select
	EnNumDate = num_months & " " & num_days &","& num_years &" at "&num_hour&":"&num_minute&" "&daymode
End Function

Function EnStrDate(ByDate)
	dim timeArray1,timeArray2,days,months,years
	timeArray1 = split(ByDate," ")
	if instr(ByDate,"-") > 0 then
		timeArray2 = split(timeArray1(0),"-")
	elseif instr(ByDate,"/") > 0 then
		timeArray2 = split(timeArray1(0),"/")
	end if
	years = timeArray2(0)
	days = timeArray2(2)
	months = timeArray2(1)
	select case months
		case "1"
			months="January"
		case "2"
			months="February"
		case "3"
			months="March"
		case "4"
			months="April"
		case "5"
			months="May"
		case "6"
			months="June"
		case "7"
			months="July"
		case "8"
			months="August"
		case "9"
			months="September"
		case "10"
			months="October"
		case "11"
			months="November"
		case else
			months="December"
	end select
	EnStrDate = months & " " & days & "," & years
End Function

Function CountComment(noteid)
	sqlCount = "select count(id) from comment where noteid = "&noteid
	set rsCount = conn.execute(sqlCount)
		Counts = rsCount(0)
	set rsCount = nothing
	CountComment = Counts
End Function

Function getID(theTitle)
	sqlGetID = "select id from notes where title='"&theTitle&"' and datediff('s', pubtime, now) < 2"
	set rsGetID = conn.execute(sqlGetID)
		theID = rsGetID("ID")
	set rsGetID = nothing
	getID = theID
End Function

Function CountsTotal()
	sqlTotal = "select count(id) from notes"
	Set rsTotal = conn.execute(sqlTotal)
		Total = rsTotal(0)
	Set rsTotal = Nothing
	CountsTotal = Total
End Function

Sub Del(id)
	conn.excute("delete * from notes where id="&id)
	call showmsg("删除成功！","back")
End Sub

'/////////////-------- 生成全部 --------//////////////////
Sub CreateAll()
	Call GetConfig()
	'组件
	'response.write(sitepath&"template/notes.html")
	'response.end
	NewFile = NewRead(server.MapPath(sitepath&"template/notes.html"),"utf-8")
	'////////////////////------循环读取数据------/////////////////
	set rs = server.CreateObject("adodb.recordset")
	sql = "select * from notes order by id desc"
	rs.open sql,conn,1,1
	if (rs.eof and rs.bof) then
		Call ShowMsg("没有任何信息，不能生成！","back")
	else
		'分页
	dim currentpage
	maxperpage=100 '每次生成条数
	rs.pagesize=maxperpage
	currentpage=page
	if currentpage="" then
		currentpage=1
	elseif currentpage<1 then
		currentpage=1
	else
		currentpage=clng(currentpage)
		if currentpage > rs.pagecount then
			currentpage=rs.pagecount
			
		end if
	end if
	
	if not isnumeric(currentpage) then
		currentpage=1
	end if
	dim totalput,n
		totalput=rs.recordcount
	if totalput mod maxperpage=0 then
		n=totalput\maxperpage
	else
		n=totalput\maxperpage+1
	end if
	if n=0 then
		n=1
	end if
	rs.move(currentpage-1)*maxperpage
	i = 0
	infostr = ""
	do while i< maxperpage and not rs.eof
		Html = ""
		Html = NewFile
		'id,title,areaid,pubdate,price,pricetype,room,area,classid,region,info,username,tel,qq,email
		notesid = rs("id")
		title = rs("title")
		content = rs("content")
		pubtime = rs("pubtime")
		formatTime = EnStrDate(pubtime)
		'path = rs("path")
		fileName = year(pubtime)&month(pubtime)&day(pubtime)&notesid&".html"	
		meta = "<meta name=""robots"" content=""all"" /><meta name=""author"" content="""&authorname&""" /><meta name=""contact"" content="""&authorcontact&""" /><meta name=""Description"" content="""&Replace(price&room&area,"<br />","，")&""" /><meta name=""Keywords"" content="""&title&""" />"
		
		'//////////生成
		HTML = replace(HTML,"<#meta#>",meta)
		HTML = replace(HTML,"<#sitepath#>",sitepath)
		HTML = replace(HTML,"<#domain#>",dDomain)
		HTML = replace(HTML,"<#siteName#>",dsitename)
		HTML = replace(HTML,"<#noteTitle#>",title)
		HTML = replace(HTML,"<#content#>",content)
		HTML = replace(HTML,"<#pubtime#>",pubtime)
		HTML = replace(HTML,"<#formatTime#>",formatTime)
		
		'创建文件目录
		Folder = sitepath&dHtmlPath&"/"&fileName
		Set fso = Server.CreateObject("Scripting.FileSystemObject")
		tArr = Split(Folder, "/")
		tStr = tArr(0)
		For k = 1 To UBound(tArr) - 1
			tStr = tStr & "/" & tArr(k)
			'Response.Write(tStr & "<p>")
			If Not fso.FolderExists(Server.MapPath(tStr)) Then fso.CreateFolder(Server.MapPath(tStr))
		Next
		Set fso = Nothing
		'response.Write(sitepath&dHtmlPath&"/"&fileName)
		'response.End()
		call Write2File(server.Mappath(Folder),HTML,"utf-8")
		infostr = infostr & title & "<br />"
	i=i+1      
	rs.movenext
	loop
	end if
	rs.close
	set rs = nothing
	if currentpage < n then
		response.Write("共需生成"&n&"批，当前第"&currentpage&"批。<br /><br />"&infostr&"<br />")
		Response.Write("<script>window.setTimeout('getUrl()',1000);function getUrl(){window.location='?creat=all&page="&currentpage+1&"';};</script>")
	elseif currentpage = n then
		call ShowMsg("生成全部结束！","create.asp")
	end if
End Sub

'生成所选
Sub getCreat(id)
	set rs = server.CreateObject("adodb.recordset")
	sql = "select * from info where id = "&clng(id)
	rs.open sql,conn,1,1
	if not (rs.eof and rs.bof) then
		Html = ""
		Html = NewFile
		If HTML = "" Then HTML = NewRead(server.MapPath(sitepath&"template/notes.html"),"utf-8")
		summary = ""
		contact = ""
		infoid = rs("id")
		title = rs("title")
		areaid = rs("areaid")
		agency = rs("agency")
		pubdate = rs("pubdate")
		price = rs("price")
		vcode = rs("vcode")
		pricetype = rs("pricetype")
		room = rs("room")
		office = rs("office")
		toilet = rs("toilet")
		area = rs("area")
		classid = rs("classid")
		region = rs("region")
		info = rs("info")
		infoC = info
		'thisPageDescription = LeftStr(ClearHTML(infoC),200)
		username = rs("username")
		tel = rs("tel")
		qq = rs("qq")
		email = rs("email")
		path = rs("path")
		if path = "" or isnull(path) then
			fileName = year(pubdate)&month(pubdate)&day(pubdate)&infoid&".html"
			path = right(year(pubdate),2)&month(pubdate)&day(pubdate)&"/"&fileName
			Call UpdatePath(infoid,path)
		end if
		'if email <> "" then
			'if IsValidEmail(email) = true then
				'if username = "" then username = "亲爱的朋友"
					'ipath = "http://www.cszufang.cn/"&HtmlFolder&path
					'spath = "http://www.cszufang.cn/self-service/?id="&infoid&"&vcode="&vcode
				'Call send(email,username,ipath,spath)
			'end if
		'end if

		areaname = getAreaName(areaid)
		'summary
		'response.write(price = 0)
		'response.end
		if price <> "" And price <> 0 then price = "价格："&price&pricetype&"<br />" Else price = "价格：面议<br />"
		if room <> "" then room = "居室："&room&"室"&office&"厅"&toilet&"卫<br />"
		if area <> "" then area = "面积："&area&"㎡<br />"
		if agency = true then agency = "我是中介<br />" else agency = ""
		if region <> "" then region = "具体位置："&region
		summary = price&room&area&agency&region
		'contact
		if username <> "" and username <> "无名" then username = "<strong>联系人：</strong>"&username&"<br />" else username = ""
		if tel <> "" then tel = "<strong>手机/电话：</strong><span class='tel'>"&tel&"</span><br />" else tel = "<strong>手机/电话：</strong>太懒了，电话都不留一个。<br />"
		if qq <> "" then qq = "<strong>QQ：</strong>"&qq&"<br />" else qq = ""
		if email <> "" then email = "<strong>E-MAIL：</strong>"&email else email = ""
		contact = username&tel&qq&email
		meta = "<meta name=""Description"" content="""&Replace(price&room&area,"<br />","，")&""" /><meta name=""Keywords"" content="""&title&""" />"
		areanav = getArea(0,"")
		classnav = getClass(classid)
		'otherlist = getOtherList(classid,areaid,infoid)
		
		'//////////生成
		HTML = replace(HTML,"<#meta#>",meta)
		HTML = replace(HTML,"<#sitepath#>",sitepath)
		HTML = replace(HTML,"<#domain#>",domain)
		HTML = replace(HTML,"<#sitename#>",sitename)
		HTML = replace(HTML,"<#classnav#>",classnav)
		HTML = replace(HTML,"<#areanav#>",areanav)
		HTML = replace(HTML,"<#infotitle#>",title)
		HTML = replace(HTML,"<#infoid#>",infoid)
		HTML = replace(HTML,"<#classid#>",classid)
		HTML = replace(HTML,"<#areaid#>",areaid)
		HTML = replace(HTML,"<#inarea#>",areaname)
		HTML = replace(HTML,"<#pubdate#>",pubdate)
		HTML = replace(HTML,"<#summary#>",summary)
		HTML = replace(HTML,"<#contact#>",contact)
		HTML = replace(HTML,"<#detail#>",info)
		'HTML = replace(HTML,"<#otherlist#>",otherlist)
		'创建文件目录
		Folder = sitepath&HtmlFolder&path
		Set fso = Server.CreateObject("Scripting.FileSystemObject")
		tArr = Split(Folder, "/")
		tStr = tArr(0)
		For i = 1 To UBound(tArr) - 1
			tStr = tStr & "/" & tArr(i)
			If Not fso.FolderExists(Server.MapPath(tStr)) Then fso.CreateFolder(Server.MapPath(tStr))
		Next
		Set fso = Nothing
		call Write2File(server.Mappath(Folder),HTML,"utf-8")
	end if
	rs.close
	set rs = nothing
End Sub
'删除所选
Sub getDel(idlist)
	Dim rsdel,sql,sqlD
	sql = "select id,path from [info] where id in ("&idlist&")"
	set rsDel = conn.execute(sql)
	if Not rsDel.eof Then
		Do While Not rsDel.eof
		Path = rsDel("Path")
		infoid = rsDel("id")
		if path <> "" or not isnull(path) then
		Set fs = Server.CreateObject("Scripting.FileSystemObject")
			infopath = server.MapPath(SitePath&HtmlFolder&Path)
			if fs.FileExists(infopath) then	
				fs.deleteFile(InfoPath)
			end if
		Set fs = Nothing
		end if
		sqlD = "delete * from Info where id="&infoid
		conn.execute(sqlD)
		rsDel.MoveNext
		Loop
	Else
		Call ShowMsg("您没有该信息编辑权限！\n或者该信息不存在！","back")
	End If
	Set rsDel = nothing
End Sub
Sub GetConfig()
	Call OpenData()
	Set rsSet = conn.execute("select top 1 site,domain,topic,topicdetail,photo,alipay,[partner],[key],[sum] from config")
	If Not rsSet.eof Then
		site	=	rsSet("site")
		domain	=	rsSet("domain")
		topic	=	rsSet("topic")
		topicDetail	=	rsSet("topicDetail")
		
		photo	=	rsSet("photo")
		alipay	=	rsSet("alipay")
		partner	=	rsSet("partner")
		key		=	rsSet("key")
		sum		=	rsSet("sum")
		sumarr = Split(sum,",")
	End If
	Set rsSet = Nothing
	Call CloseData()
End Sub
%>